(in-package :cl-fast-ecs)

(deftype entity () "An entity type, basically just a `FIXNUM`." 'fixnum)

(declaim (type array-length *storage-entities-allocated*))
(define-global-var *storage-entities-allocated* 0)

#-ecs-release
(defclass component-soa ()
  ((allocated
    :accessor component-soa-allocated
    :initarg :allocated
    :initform *storage-entities-allocated*
    :type array-length)
   (exists
    :accessor component-soa-exists
    :initform (make-array *storage-entities-allocated*
                          :element-type 'bit :initial-element 0)
    :type simple-bit-vector)
   (min-entity
    :accessor component-soa-min-entity
    :initform array-dimension-limit
    :type entity)
   (max-entity
    :accessor component-soa-max-entity
    :initform -1
    :type entity)
   (count
    :accessor component-soa-count
    :initform 0
    :type array-length)))

#+ecs-release
(defstruct (component-soa
            (:copier nil)
            (:predicate nil))
  (allocated *storage-entities-allocated* :type array-length)
  (exists (make-array *storage-entities-allocated*
                      :element-type 'bit :initial-element 0)
   :type simple-bit-vector)
  (min-entity array-dimension-limit :type entity)
  (max-entity -1 :type entity)
  (count 0 :type array-length))

(defstruct (storage (:constructor %make-storage))
  (entities-count 0 :type array-length)
  (deleted-entities nil :type (simple-array entity (*)))
  (deleted-entities-count 0 :type array-length)
  (component-storages nil :type (simple-array (or component-soa null) (*)))
  (component-created-bits nil :type simple-bit-vector)
  (component-removed-bits nil :type simple-bit-vector))

(declaim (type (or null storage) *storage*))
(define-global-var *storage* nil)
(setf (documentation '*storage* 'variable)
      "Global component data storage instance to be used by virtually all
library functions.

NOTE: it is set to `NIL` initially, meaning it is not initialized yet.

See also `MAKE-STORAGE`.")

(declaim (ftype (function () (values storage &optional)) %get-storage)
         #-ecs-release (notinline %get-storage)
         #+ecs-release (inline %get-storage))
(defun %get-storage ()
  (declare (optimize (speed 3)))
  #-ecs-release
  (if-let (storage *storage*)
    storage
    (restart-case (error "ECS storage is not initialized")
      (initialize-storage ()
        :report "Initialize storage with default settings"
        (setf *storage* (make-storage)))))
  #+ecs-release
  *storage*)

(defmacro with-storage ((&optional storage-var) &body body)
  (let ((storage-var (if storage-var storage-var 'storage)))
    `(let ((,storage-var (%get-storage)))
       (declare (type storage ,storage-var))
       ,@body)))

(declaim #-ecl
         (#+sbcl sb-ext:global
          #+lispworks hcl:special-global
          #-(or sbcl lispworks) special
          *component-registry* *component-registry-length*)
         (type list *component-registry*)
         (type array-length *component-registry-length*))

#-ecs-release
(progn
  (defclass component-soa-slot (c2mop:standard-direct-slot-definition)
    ((slot-type
      :accessor slot-type
      :initarg :slot-type)
     (slot-index
      :accessor slot-index
      :initarg :slot-index
      :initform nil)
     (slot-index-unique
      :accessor slot-index-unique
      :initarg :slot-index-unique
      :initform nil)
     (slot-composite-index
      :accessor slot-composite-index
      :initarg :slot-composite-index
      :initform nil)
     (slot-composite-index-unique
      :accessor slot-composite-index-unique
      :initarg :slot-composite-index-unique
      :initform nil)
     (obsoletep
      :accessor obsoletep
      :initarg :obsoletep
      :initform nil)))

  (defclass component-soa-class (c2mop:standard-class) ())

  (defmethod c2mop:validate-superclass ((class component-soa-class)
                                        (super c2mop:standard-class))
    t)

  (defmethod c2mop:direct-slot-definition-class ((class component-soa-class)
                                                 &rest initargs)
    (declare (ignore class initargs))
    (find-class 'component-soa-slot))

  (defmethod initialize-instance :after ((soa-class component-soa-class)
                                         &key &allow-other-keys)
    (when *storage*
      (let* ((storage *storage*)
             (index *component-registry-length*)
             (soa (make-instance soa-class))
             (component-storages (storage-component-storages storage))
             (length (length component-storages)))
        (when (>= index length)
          (setf component-storages
                (adjust-simple-arrayf (storage-component-storages storage)
                                      (setf length (1+ index))
                                      :element-type '(or component-soa null)
                                      :initial-element 'nil))
          (adjust-simple-arrayf (storage-component-created-bits storage)
                                length :element-type 'bit :initial-element 1)
          (adjust-simple-arrayf (storage-component-removed-bits storage)
                                length :element-type 'bit :initial-element 0))
        (setf (svref component-storages index) soa))))

  (defmethod shared-initialize :around ((soa-class component-soa-class) slots
                                        &rest initargs)
    (let ((obsolete-slots nil))
      (unless (eq slots t)
        (setf initargs (copy-list initargs))
        (let ((slots-initargs (getf initargs :direct-slots)))
          (dolist (slot (c2mop:class-direct-slots soa-class))
            (let ((slot-name (c2mop:slot-definition-name slot)))
              (when-let ((slot-initargs
                          (find slot-name slots-initargs
                                :key (lambda (initarg) (getf initarg :name)))))
                (let ((slot-type
                        (getf slot-initargs :slot-type))
                      (slot-index
                        (getf slot-initargs :slot-index))
                      (slot-index-unique
                        (getf slot-initargs :slot-index-unique))
                      (slot-composite-index
                        (getf slot-initargs :slot-composite-index))
                      (slot-composite-index-unique
                        (getf slot-initargs :slot-composite-index-unique)))
                  (when (or
                         (not (eq (when (slot-index slot) t)
                                  (when slot-index t)))
                         (not (eq (slot-index-unique slot) slot-index-unique))
                         (not (eq (when (slot-composite-index slot) t)
                                  (when slot-composite-index t)))
                         (not (eq (slot-composite-index-unique slot)
                                  slot-composite-index-unique))
                         (and (not slot-index)
                              (not slot-composite-index)
                              (not (subtypep (slot-type slot) slot-type)))
                         (and (or slot-index slot-composite-index)
                              (not (equalp (slot-type slot) slot-type))))
                    (nconc slot-initargs '(:obsoletep t))
                    (push slot-name obsolete-slots))))))))
      (let ((instance (apply #'call-next-method soa-class slots initargs)))
        #-ecl
        (dolist (slot (c2mop:class-direct-slots soa-class))
          (setf (obsoletep slot)
                (and (find (c2mop:slot-definition-name slot) obsolete-slots
                           :test #'eq)
                     t)))
        instance)))

  (defmethod update-instance-for-redefined-class ((soa component-soa)
                                                  added deleted plist
                                                  &rest rest)
    (let* ((obsolete-slots (remove-if-not
                            #'obsoletep
                            (c2mop:class-direct-slots (class-of soa))))
           (obsolete-slot-names (mapcar #'c2mop:slot-definition-name
                                        obsolete-slots)))
      (dolist (slot obsolete-slots)
        (slot-makunbound soa (c2mop:slot-definition-name slot)))
      (apply #'call-next-method
             soa
             (append added (mapcar #'c2mop:slot-definition-name obsolete-slots))
             deleted plist rest)
      ;; rebuild indices
      (let ((soa-index (position soa (storage-component-storages *storage*)
                                 :test #'eq)))
        (dolist (slot (c2mop:class-direct-slots (class-of soa)))
          (let ((slot-name (c2mop:slot-definition-name slot))
                (index-p (slot-index slot))
                (composite-index-p (slot-composite-index slot)))
            (when (and (or index-p composite-index-p)
                       (find slot-name obsolete-slot-names :test #'eq))
              (adjust-simple-arrayf
               (slot-value soa slot-name)
               (component-soa-count soa)
               :element-type '(or null (simple-array fixnum (*)))
               :initial-element nil)
              (loop
                :with slot-name* :of-type symbol
                  := (if composite-index-p (first composite-index-p) index-p)
                :with slot-array :of-type simple-array
                  := (slot-value soa slot-name*)
                :with slot-name :of-type keyword := (make-keyword slot-name*)
                    :for entity :of-type entity
                      :from (component-soa-min-entity soa)
                        :to (component-soa-max-entity soa)
                :do (apply #'assign-component soa-index entity
                           `(,slot-name
                             ,(aref slot-array entity)))))))))))

(defhook :storage-initialized
  :documentation
  "Called after the storate was initialized. Argument for the call is the newly
initialized storage instance (also available at `*STORAGE*` variable).

See `MAKE-STORAGE`, `HOOK-UP`.")

(defun make-storage (&key (initial-allocated 32))
  "Initializes a new component data storage.

Optional `INITIAL-ALLOCATED` argument sets the initial count of pre-allocated
entities and defaults to 32.

Note: this triggers initialization of entity variables defined by `DEFENTITY`.

See also `*STORAGE*`."
  (check-type initial-allocated array-length)
  (assert (> initial-allocated 1) (initial-allocated)
          "Initial allocated size should be greater than 1.")
  (check-type initial-allocated array-length)
  (setf *storage-entities-allocated* initial-allocated
        *storage*
        (%make-storage
         :deleted-entities (make-array initial-allocated
                                       :element-type 'entity
                                       :initial-element -1)
         :component-storages
         (make-array
          *component-registry-length*
          :element-type 'component-soa
          :initial-contents
          (reverse
           (loop :for (nil component-ctor)
                   :on *component-registry* :by #'cddr
                 :for i :of-type array-index :from 0
                 :collect
                 #-ecs-release
                  (make-instance component-ctor)
                 #+ecs-release
                  (funcall component-ctor))))
         :component-created-bits (make-array *component-registry-length*
                                             :element-type 'bit
                                             :initial-element 1)
         :component-removed-bits (make-array *component-registry-length*
                                             :element-type 'bit
                                             :initial-element 0)))
  (run-hook *storage-initialized-hook* *storage*)
  *storage*)

(defmethod print-object ((obj storage) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "of ~a component~:p [~a entit~:@p]"
            (length (storage-component-storages obj))
            (storage-entities-count obj))))
